home *** CD-ROM | disk | FTP | other *** search
/ Delphi Informant Complete 1995 - 2000 / Delphi Informant Complete 1995 to 2000.iso / Delphi Informant Magazine Complete Works SOURCE CODE 1998.rar / 1998 / Jul / di9807rl / viewform.pas < prev    next >
Pascal/Delphi Source File  |  1998-02-26  |  4KB  |  155 lines
  1. unit ViewForm;
  2.  
  3. { Simple program that displays the current system palette.
  4.   Copyright ⌐ 1998 Tempest Software, Inc.
  5. }
  6.  
  7. interface
  8.  
  9. uses
  10.   SysUtils, Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs,
  11.   StdCtrls, ComCtrls, ExtCtrls;
  12.  
  13. type
  14.   TPaletteForm = class(TForm)
  15.     ErrorLabel: TLabel;
  16.     StatusBar: TStatusBar;
  17.     ColorPanel: TPaintBox;
  18.     procedure ColorPanelPaint(Sender: TObject);
  19.     procedure FormResize(Sender: TObject);
  20.     procedure FormDestroy(Sender: TObject);
  21.     procedure FormCreate(Sender: TObject);
  22.     procedure ColorPanelMouseMove(Sender: TObject; Shift: TShiftState; X,
  23.       Y: Integer);
  24.   private
  25.     fNumColors: Word;
  26.     fPalette: HPalette;
  27.   protected
  28.     function GetPalette: HPalette; override;
  29.     property Palette: HPalette read fPalette;
  30.     property NumColors: Word read fNumColors;
  31.   end;
  32.  
  33. var
  34.   PaletteForm: TPaletteForm;
  35.  
  36. implementation
  37.  
  38. {$R *.DFM}
  39.  
  40. // Set up the form's palette to display the system palette.
  41. procedure TPaletteForm.FormCreate(Sender: TObject);
  42. var
  43.   LogPal: PLogPalette;
  44.   Size: LongInt;
  45.   I: Word;
  46. begin
  47.   if (GetDeviceCaps(Canvas.Handle, RasterCaps) and Rc_Palette) = 0 then
  48.   begin
  49.     ErrorLabel.Visible := True;
  50.     Exit;
  51.   end;
  52.  
  53.   fNumColors := GetDeviceCaps(Canvas.Handle, SizePalette);
  54.   Size := SizeOf(TLogPalette) + LongInt(NumColors-1) * SizeOf(TPaletteEntry);
  55.   GetMem(LogPal, Size);
  56.  
  57.   LogPal^.palVersion := $300;
  58.   LogPal^.palNumEntries := NumColors;
  59.   for I := 0 to NumColors-1 do
  60.   begin
  61.   {$R-}
  62.     LongInt(LogPal^.palPalEntry[I]) := I;
  63.     LogPal^.palPalEntry[I].peFlags := Pc_Explicit;
  64.   {$R+}
  65.   end;
  66.  
  67.   fPalette := CreatePalette(LogPal^);
  68.   if fPalette = 0 then
  69.     raise EOutOfResources.Create('Cannot create palette');
  70. end;
  71.  
  72. // Free the palette when the form closes
  73. procedure TPaletteForm.FormDestroy(Sender: TObject);
  74. begin
  75.   if fPalette <> 0 then
  76.     DeleteObject(fPalette);
  77.   fPalette := 0;
  78. end;
  79.  
  80. // Return the form's palette.
  81. function TPaletteForm.GetPalette: HPalette;
  82. begin
  83.   if fPalette <> 0 then
  84.     Result := fPalette
  85.   else
  86.     Result := inherited GetPalette
  87. end;
  88.  
  89. // Paint the form with a grid of boxes, where each box is filled
  90. // with a palette color. To make it easier to see the colors,
  91. // leave a small margin around each box and around the edge of
  92. // the form.
  93. procedure TPaletteForm.ColorPanelPaint(Sender: TObject);
  94. const
  95.   NCols = 16;
  96.   Margin = 2;
  97. var
  98.   I: Integer;
  99.   X, Y: Integer; // top, left corner of the next box
  100.   W, H: Integer; // size of each box
  101.   NRows: Integer;
  102.   OldPal: HPalette;
  103. begin
  104.   // Non-palette device?
  105.   if Palette = 0 then
  106.     Exit;
  107.  
  108.   OldPal := SelectPalette(ColorPanel.Canvas.Handle, Palette, False);
  109.   try
  110.     ColorPanel.Canvas.Pen.Color := clBlack;
  111.  
  112.     NRows := (LongInt(NumColors)+NCols-1) div NCols;
  113.     W := ColorPanel.ClientWidth div NCols - Margin;
  114.     H := ColorPanel.ClientHeight div NRows - Margin;
  115.     X := 1;
  116.     Y := 1;
  117.     for I := 0 to NumColors-1 do
  118.     begin
  119.       ColorPanel.Canvas.Brush.Color := PaletteIndex(I);
  120.       ColorPanel.Canvas.Rectangle(X, Y, X+W, Y+H);
  121.       // Determine the position of the next box: does it fit
  122.       // on the current line, or start a new row?
  123.       if I mod NCols < NCols-1 then
  124.         X := X + W + Margin
  125.       else
  126.       begin
  127.         X := 1;
  128.         Y := Y + H + Margin;
  129.       end;
  130.     end;
  131.   finally
  132.     SelectPalette(ColorPanel.Canvas.Handle, OldPal, True);
  133.   end;
  134. end;
  135.  
  136. // Redraw the palette boxes when the form changes size
  137. procedure TPaletteForm.FormResize(Sender: TObject);
  138. begin
  139.   ColorPanel.Invalidate
  140. end;
  141.  
  142. // Display the color of the pixel under the mouse.
  143. procedure TPaletteForm.ColorPanelMouseMove(Sender: TObject;
  144.   Shift: TShiftState; X, Y: Integer);
  145. var
  146.   Color: LongInt;
  147. begin
  148.   Color := ColorPanel.Canvas.Pixels[X, Y];
  149.   StatusBar.Panels[0].Text := Format('R: $%2.2X', [GetRValue(Color)]);
  150.   StatusBar.Panels[1].Text := Format('G: $%2.2X', [GetGValue(Color)]);
  151.   StatusBar.Panels[2].Text := Format('B: $%2.2X', [GetBValue(Color)]);
  152. end;
  153.  
  154. end.
  155.